Row

City Response Rate

Ward Response Rate

Ward

17 / 50

Ward

20,622

Ward

13,490

Ward

21

Row

Daily results for Ward 50

Row

Citywide performance

Ward 50

Row

Census tract demographics for Ward 50

---
title: "Census 2020 Ward Level Results"
output: 
  flexdashboard::flex_dashboard:
    orientation: rows
    vertical_layout: scroll #fill
    social: menu
    source_code: embed
# runtime: shiny
editor_options: 
  chunk_output_type: console
---

```{r, include = FALSE}

## See: https://github.com/Chicago/census2020_ward_rpt/

geneorama::set_project_dir("census2020_ward_rpt")

# rm(list=ls())

library(shiny)
library(leaflet)
library(RColorBrewer)
library(colorspace)
library(rgdal) #for reading/writing geo files
library(rgeos) #for simplification
library(sp)
library(data.table)
library(plotly)
# library(tmap)
library(sf)
library(reactable)
library(tmap)
library(flexdashboard)
library(htmltools)
library(yaml)
library(bit64)

source("functions/sourceDir.R")
sourceDir("functions")

## LOAD CURRENT DATA AND CURRENT WARD
##*********************
##*********************
##*********************
load(max(list.files("ward_report/cache", full.names = T)))
cur_ward <- yaml::read_yaml("ward_report/cur_ward.yaml")
cur_ward <- cur_ward$cur_ward
##*********************
##*********************
##*********************

## Ward / tract crosswalk
ward_crosswalk <- fread("data_census_planning/crosswalk_replica_based.csv")
ward_crosswalk[ , tract := substr(TRACT, 6, 11)]

## Create data table for maps / summaries of all responses
resp_current$state <- NULL
resp_current$county <- NULL

resp_current <- merge(resp_current,
                      civis_pdb,
                      by.x = "TRACT",
                      by.y = "tract",
                      all.x = TRUE)
resp_current <- resp_current[!is.na(TRACT)]

## HTC instead?
htc[ , tract_2020 := substr(TRACT_2020, 6, 11)]
resp_current <- merge(resp_current,
                      htc[!is.na(TRACT_2020), MailReturnRateCen2010:tract_2020],
                      by.x = "TRACT",
                      by.y = "tract_2020",
                      all.x = TRUE)
# NAsummary(resp_current)
resp_current <- resp_current[!is.na(TRACT)]
# resp_current[!is.na(gidtr)]

## Calculate ward household table
resp_cur_ward <- merge(ward_crosswalk[ward == cur_ward,
                                      list(TRACT = tract,
                                           ward, 
                                           households_ward = households,
                                           households_tract = tract_total,
                                           allocation)], 
                       resp_current, 
                       by = "TRACT")

## Shape file of just current ward
shp_ward <- shp_wards[shp_wards$ward == cur_ward, ]
civis_ward_table <- civis_ward_table[match(shp_wards$ward, civis_ward_table$ward)]
civis_ward_table[ , LABEL := htmltools::HTML(hover_text), ward]

## Tract map of just this ward
## put data in same order as map
shp_ward_tract <- shp_tracts_2020[shp_tracts_2020@data$TRACT %in% resp_cur_ward$TRACT, ]
resp_cur_ward <- resp_cur_ward[match(shp_ward_tract@data$TRACT, resp_cur_ward$TRACT)]

## put data in same order as map
resp_current <- resp_current[match(shp_tracts_2020$TRACT, TRACT)]

## Map color definitions
cur_pal <- c("#754C17", "#B96B34", "#F29946", "#E0C245", 
             # "#99DFF1",
             "#3BB8E2", "#7999B7", 
             "#A18EB9",
             "#694D87", "#3D2E4E")

## City wide response
city_target_resp <- 75
city_cur_resp <- civis_ward_table[
  i = TRUE,
  j = sum(tot_occp_units_acs_13_17 * current_response_rate) / sum(tot_occp_units_acs_13_17)]
city_target_resp_civis <- civis_ward_table[
  i = TRUE,
  j = sum(tot_occp_units_acs_13_17 * civis_2020_target) / sum(tot_occp_units_acs_13_17)]
city_cur_resp <- round(city_cur_resp, 1)

## Ward specific respopnse numbers
ward_target_resp <- civis_ward_table[match(cur_ward, ward), adjusted_civis_2020_target]
ward_cur_resp <- civis_ward_table[match(cur_ward, ward), current_response_rate]
ward_target_resp_civis <- civis_ward_table[match(cur_ward, ward), civis_2020_target]
ward_ranking_table_adj <- civis_ward_table[i = TRUE,
                                           list(ward,
                                                current_response_rate,
                                                rank = 1 +.N - rank(percent_to_target))]
ward_ranking_adj <- ward_ranking_table_adj[ward == cur_ward, rank]

## Household totals for value boxes
ward_hh_tot <- resp_cur_ward[ , sum(households_ward)]
ward_hh_resp_daily <- resp_cur_ward[ , round(sum(households_ward * DRRALL/100))]
ward_hh_resp_total <- resp_cur_ward[ , round(sum(households_ward * CRRALL/100))]

## Old way, see below for new way
## Create the ward-specific overlap files to be used in the making the map and table
# ii <- which(gOverlaps(spgeom1 = shp_tracts_2020,
#                       spgeom2 = shp_wards[shp_wards@data$ward == cur_ward, ],
#                       byid = TRUE)[1,])
# tracts_in_ward <- shp_tracts_2020@data[ii, "TRACT"]

## Merge civis and response data into census data
# shp_tracts_2020@data <- cbind(shp_tracts_2020@data,
#                               civis_pdb[match(shp_tracts_2020@data$TRACT, tract)],
#                               resp_current[match(shp_tracts_2020@data$TRACT, TRACT),
#                                            list(RESP_DATE, CRRALL,CRRINT)])
# lll()
# wtf(resp_cur_ward)
ward_labels <- 
  resp_cur_ward[i = TRUE, 
                j = list(LABEL = htmltools::HTML(
                  paste(paste0("Tract: ", TRACT),
                        paste0("As of ", RESP_DATE),
                        paste0("Total response rate is ", CRRALL, "%"),
                        paste0("Total internet response rate is ", CRRINT, "%"),
                        paste0("Households in tract: ",
                               prettyNum(TotHH, big.mark=",")),
                        paste0("Households in ward: ",
                               prettyNum(round(TotHH*households_ward/households_tract), 
                                         big.mark=",")),
                        paste0("Response rate 2010 (mail): ", mail_return_rate_cen_2010, "%"),
                        paste0("Predicted 2020 response rate:", 100-low_response_score, "%"),
                        paste0("Total population 2010:", tot_population_cen_2010),
                        paste0("Black population 2010:", nh_blk_alone_acs_13_17),
                        paste0("Hisp. population 2010:", hispanic_acs_13_17),
                        paste0("Limited English Proficiency (LEP):", eng_vw_acs_13_17),
                        paste0("Single Parents:", HH_SingleParent),
                        sep = "
"))), by = TRACT] # str(ward_labels) ``` Row {data-height=120} ------------------------------------- ### City Response Rate ```{r} gauge(value = city_cur_resp, label = "City", symbol = "%", min = 0, max = 100, gaugeSectors(success = c(city_target_resp, 100), warning = c(city_target_resp-20, city_target_resp), danger = c(0, city_target_resp-20))) ``` ### Ward Response Rate ```{r} gauge(value = ward_cur_resp, label = "Ward", symbol = "%", min = 0, max = 100, gaugeSectors(success = c(ward_target_resp, 100), warning = c(ward_target_resp_civis, ward_target_resp), danger = c(0, ward_target_resp_civis))) ``` ### Ward ```{r} valueBox(value = paste0(ward_ranking_adj, " / 50"), caption = paste0("Ward ", cur_ward, "'s Current Rank!"), icon = "fa-trophy", color = "success") ``` ### Ward ```{r} valueBox(value = prettyNum(ward_hh_tot, big.mark = ","), caption = paste0("Total households in Ward ", cur_ward), icon = "fa-pencil", color = "info") ``` ### Ward ```{r} valueBox(value = prettyNum(ward_hh_resp_total, big.mark = ","), caption = paste0("Total Household Responses for Ward ", cur_ward), icon = "fa-pencil", color = "info") ``` ### Ward ```{r} valueBox(value = prettyNum(ward_hh_resp_daily, big.mark = ","), caption = paste0("Daily responses for Ward ", cur_ward, " on ", max(resp_current$RESP_DATE, na.rm=T)), icon = "fa-pencil", color = "info") ``` Row {data-height=400} ------------------------------------- ### Daily results for Ward `r cur_ward` ```{r} # # output$daily_performance <- renderPlotly({ fig <- plot_ly(data = civis_daily_rates[!ward==cur_ward, list(response_date, response_rate = round(response_rate,1))], x = ~response_date, y = ~response_rate, showlegend = FALSE, # color = ~ward, color = I("grey80"), name = paste("Ward", civis_daily_rates[!ward==cur_ward]$ward), type = "scatter", mode="lines") fig <- layout(fig, title = paste0("Cumulative Daily Response Rate\n Ward ", cur_ward), xaxis = list(title = "Household % Responding"), yaxis = list (title = "")) fig <- civis_daily_rates[ward==cur_ward, add_lines(fig, x=response_date, y=response_rate, name = paste("Ward", cur_ward), color = I("blue"))] fig <- fig %>% layout(shapes = list(plotly_vline("2020-04-30", dash = "dash"), plotly_hline(ward_target_resp, dash = "dot", color = "green"), plotly_hline(100, dash = "solid")), margin = list(t=80)) # default margins: # margin = list(l = 80, r = 80, b = 80, t = 100, pad = 0) fig <- add_text(fig, x=as.IDate("2020-03-20"), y = ward_target_resp + 5, text = paste0("Goal for Ward ", cur_ward, " is ", ward_target_resp, "%" ), color = I("gray20"), showlegend = FALSE) fig # }) # plotlyOutput("daily_performance", width = "50%") # p <- ggplot() + # geom_errorbar(data = civis_daily_rates[i = TRUE, # j = list(max = max(response_rate), # min = min(response_rate)), # by = response_date], # aes(x = response_date, # ymin = min, # ymax = max), # width = 1, # colour = "gray70")+ # geom_line(data = civis_daily_rates[i = ward == cur_ward, # j = list(response_date = response_date, # response_rate, # ward = paste("Ward ", ward))], # aes(x = response_date, y = response_rate, colour = ward), # size = 2)+ # xlim(c(as.IDate("2020-03-15"), as.IDate("2020-04-30"))) + # ylim(c(0, 110)) + # geom_hline(yintercept=100, linetype="dashed", color = "black") + # geom_hline(yintercept=ward_target_resp, linetype="dashed", color = "darkgreen") + # geom_segment(aes(x = as.IDate("2020-04-30"), y = 15, # xend = as.IDate("2020-04-30"), yend = 100)) + # annotate(geom = "text", x = as.IDate("2020-04-29"), y = 50, # label = "April 30", color = "black", angle = 90) + # annotate(geom = "text", x = as.IDate("2020-03-15"), y = ward_target_resp+5, # label = paste0("Goal for Ward ", cur_ward, " is ", ward_target_resp, "%" ), # color = "darkgreen", angle = 0, hjust = "left") + # annotate(geom = "text", x = as.IDate("2020-03-15"), y = 100+5, # label = paste0("100%"), # color = "black", angle = 0, hjust = "left") + # ggtitle("Cumulative Daily Household Response Rate", # subtitle=paste0("Ward ", cur_ward)) + # xlab("") + ylab("Household % Responding")+ # theme_bw() + # theme(legend.text = element_text(size=15, face="bold"), # legend.justification=c(1,0), # legend.position=c(1,0), # legend.title = element_blank()) # # ggplotly(p) # p ``` Row {data-height=600} ------------------------------------- ### Citywide performance ```{r} vec <- civis_ward_table$current_response_rate paldomain <- c(1,100) # paldomain <- vec pal <- colorNumeric(palette = cur_pal, domain = paldomain) labs <- shp_ward_centroids labs$ward <- as.character(shp_wards$ward) leaflet() %>% addProviderTiles("Stamen.TonerHybrid") %>% addPolygons(data = shp_wards, fillColor = ~ pal(vec), fillOpacity = 0.8, weight = 0.5, label = ~civis_ward_table$LABEL) %>% addLabelOnlyMarkers(data = labs, ~labs$x, ~labs$y, label = ~as.character(labs$ward), labelOptions = labelOptions(noHide = TRUE, direction = "center", offset = c(0, 0), opacity = 1, textsize = "12px", textOnly = TRUE, style = list("font-style" = "bold"))) %>% addLegend(pal = pal, values = paldomain, title = "% Resp Rate", position = "bottomright") # vec <- shp_tracts_2020$CRRALL # pal <- colorNumeric(palette = cur_pal, domain = vec) # leaflet() %>% # addProviderTiles("Stamen.TonerHybrid") %>% # addPolygons(data = shp_tracts_2020, # fillColor = ~ pal(vec), # fillOpacity = 0.7, weight = 0.5, # # label = ~ ward_spdf$TRACT, # label = ~ vec) %>% # addLegend(pal = pal, # values = vec, # title = "% Resp Rate", # position = "bottomright") ``` ### Ward `r cur_ward` ```{r} # output$wardmap <- renderLeaflet({ vec <- resp_cur_ward$CRRALL # pal <- colorNumeric(palette = cols_muted, domain = vec) pal <- colorNumeric(palette = cur_pal, domain = c(0,100)) leaflet() %>% addProviderTiles("Stamen.TonerHybrid") %>% addPolygons(data = shp_ward_tract, fillColor = ~ pal(vec), fillOpacity = 0.7, weight = 0.5, # label = ~ ward_spdf$TRACT, label = ~ ward_labels$LABEL) %>% addPolygons(data = shp_ward, fill = FALSE, color = "yellow", weight = 5, opacity = .75) %>% addPolygons(data = shp_ward, fill = FALSE, color = "blue", weight = 2, opacity = 1) %>% addLabelOnlyMarkers(data = shp_ward_tract, lng = ~lon_centroid, lat = ~lat_centroid, label = ~as.character(TRACT), labelOptions = labelOptions(noHide = TRUE, direction = "center", offset = c(0, 0), opacity = 1, textsize = "12px", textOnly = TRUE, style = list("font-style" = "bold"))) %>% addLegend(pal = pal, values = c(0,100), title = "% Resp Rate", position = "bottomright") # }) # leafletOutput("wardmap", width = "50%", height = 400) ``` Row {data-height=650} ------------------------------------- ### Census tract demographics for Ward `r cur_ward` ```{r} ##------------------------------------------------------------------------------ ## data table to show ward demographics - that will be saved as dt2 ##------------------------------------------------------------------------------ # civis_pdb[match(tracts_in_ward, tract)] # colnames(civis_pdb) r <- function(x) round(x, 2) dt2 <- resp_cur_ward[i = TRUE, j = list(low_response_score = round(low_response_score, 0), tot_population_cen_2010, nh_blk_alone_acs_13_17, hispanic_acs_13_17, tot_housing_units_cen_2010, eng_vw_acs_13_17, HH_SingleParent, perc_LEP = r(eng_vw_acs_13_17 / tot_housing_units_cen_2010), perc_SP = r(HH_SingleParent / tot_housing_units_cen_2010)), by = list(TRACT)] dt2 <- merge(resp_cur_ward[ , list(CRRALL=r(CRRALL/100), TRACT)], dt2, "TRACT") now <- as.POSIXct(max(resp_current$RESP_DATE, na.rm=TRUE)) now <- paste0(format(now, "%b"), " ", gsub("^0","",format(now, "%d"))) ##------------------------------------------------------------------------------ ## Reactable table ##------------------------------------------------------------------------------ stylefn <- function(x){ col <- colorNumeric(palette = cur_pal, domain = c(0,1))(x) ret <- list(background = col) return(ret) } rtable <- reactable(dt2, defaultColDef = colDef(align = "center", maxWidth = 70, headerStyle = list(background = "#f7f7f8"), format = colFormat(separators = T)), columns = list (TRACT = colDef(name = "Census Tract"), CRRALL = colDef(name = paste("2020 % Responded as of", now), defaultSortOrder = "asc", style = stylefn, format = colFormat(percent = T), width = 110), low_response_score = colDef(name = "Low Resp. Score"), tot_population_cen_2010 = colDef(name = "Total"), nh_blk_alone_acs_13_17 = colDef(name = "Black"), hispanic_acs_13_17 = colDef(name = "Hisp."), tot_housing_units_cen_2010 = colDef(name = "Total"), eng_vw_acs_13_17 = colDef(name = "Limited English Proficiency (LEP)", width = 95), perc_LEP = colDef(name = "% LEP", format = colFormat(percent = T)), HH_SingleParent = colDef(name = "Single Parent"), perc_SP = colDef(name = "% Single Parent", format = colFormat(percent = TRUE)) ), columnGroups = list(colGroup(name = "Population", columns = c("tot_population_cen_2010", "nh_blk_alone_acs_13_17", "hispanic_acs_13_17")), colGroup(name = "Households", columns = c("tot_housing_units_cen_2010", "eng_vw_acs_13_17", "perc_LEP", "HH_SingleParent", "perc_SP"))), defaultPageSize = 25, bordered = TRUE, resizable = TRUE, defaultSorted = "CRRALL") rtable ``` ```{r, include = FALSE} ## Rank Table # output$ward_demographics <- renderReactable({rtable}) # reactableOutput("ward_demographics") # #Next, use Reactable to come up with a rank table that highlights the specific position # #the ward has in comparison to other wards. # rowfn <- function(index) { # a <- which(rankdt$ward == ward) # if (index == a) list(background = "rgba(252, 140, 140, 0.5)") # } # ranktable <- reactable(rankdt, # columns = list(ward = colDef(name = "Ward", format = colFormat(digits = 0)), # mean_response = colDef(name = "Raw Response Rate (%)"), # mean_handicap = colDef(name = "Weighting Factor"), # mean_weightedresponse = colDef(name = "Weighted Response Rate (%)", # defaultSortOrder = "desc") # ), # rowStyle = rowfn, # bordered = TRUE, resizable = TRUE, defaultSorted = "mean_weightedresponse", defaultColDef = colDef(format = colFormat(digits = 2)) # ) # # #Last, display the ranking as a raw number # ranking <- rankings[rankdt$ward==ward] # ranking <- 50 - ranking ``` ```{r, include=FALSE} ## TMAP VERSION NOT WORKING BECAUSE IT WON'T RENDER IN DASHBOARD # ## Create the ward-specific overlap files to be used in the making the map and table # ii <- which(gOverlaps(spgeom1 = shp_tracts_2020, # spgeom2 = shp_wards[shp_wards@data$ward == cur_ward, ], # byid = TRUE)[1,]) # tracts_in_ward <- shp_tracts_2020@data[ii, "TRACT"] # # ## Subset map to ward # ward_spdf <- shp_tracts_2020[ii, ] # head(ward_spdf@data) # # #convert file to tmap format # ward_sf <- st_as_sf(ward_spdf, crs = 4326) # # ##------------------------------------------------------------------------------ # ## Ward map based on Civis planning database # ##------------------------------------------------------------------------------ # #start by defining variables that will pop up and breaks # popups <- c("tract", "low_response_score", "tot_population_cen_2010", # "tot_housing_units_cen_2010", "nh_blk_alone_acs_13_17", # "hispanic_acs_13_17", "eng_vw_acs_13_17" # # , "HH_SingleParent" # ) # breaks <- seq(0, 45, by = 5) # # popups%in% colnames(ward_spdf@data) # # #this will actually make the map # map1 <- tm_shape(ward_sf, is.master = TRUE) + # tm_polygons(col = "low_response_score", palette = c("#FFFFFF","#22556F"), # style="cont", alpha = .7, title = "Low Response Score", # breaks=breaks, popup.var = popups, # group = "Relevant Ward Census Tracts") + # tm_layout(title = "Heatmap of Low Response Scores") + # tm_view(view.legend.position = c("left", "bottom")) + # tm_basemap(server = "OpenMapSurfer.Roads") + # tm_shape(ward_spdf) + # tm_borders(col = "black", lwd=3, group = paste0("Ward ", cur_ward, " Outline")) # # current.mode <- tmap_mode(c("plot", "view")[2]) # tmap_leaflet(map1) ```